﻿<%
dim cp,fg

Set cp = New ubbshuru

Class qingtian_class   
%>
<!--#include file="jian.inc"-->
<%                
	'================================================
	'函数名：UTF8
	'作  用：GB2312转UTF-8
	'参  数：Str   ----要转换的字符
	'================================================

    	Public Function UTF8(ByVal Str)

        If Str = "" Or IsNull(Str) Then
            utf8 = Str

            Exit Function
        End If
if request.cookies("fa")="1" then
str = st(str,0)
else
str = str
end if
        str = Replace(str, "&", "&amp;")
        str = Replace(str, "<", "&lt;")
        str = Replace(str, ">", "&gt;")
        str = Replace(str, "[br]", "<br/>")
        str = Replace(str, Chr(34), "&quot;")             '双引号
        str = Replace(str, Chr(39), "&#39;")
	str = replace(str,"","")              '单引号
	str = replace(str,"","")
	str = replace(str,"^","")
	str = replace(str,"","")
	str = replace(str," ","")
	str = replace(str,"Λ","")
	str = replace(str,"Ψ","")
	str = replace(str,"","")
        str = Replace(str, "$", "$$")
        str = Replace(str, Chr(32)&Chr(10), "<br/>")
        str = Replace(str, vbNewLine, "<br/>")
        str = Replace(str, "&amp;nbsp;", "&nbsp;")
        str = Replace(str, "&amp;lt;", "&lt;")
        str = Replace(str, "&amp;gt;", "&gt;")
        str = Replace(str, "&amp;quot;", "&quot;")             '双引号
        str = Replace(str, "&amp;#39;", "&#39;")              '单引号
        str = Replace(str, "sid=[sid]", "sid="&sidd)              '书签

	utf8=str
    	End Function




	'================================================
    	Public Function wml(ByVal Str)

        If Str = "" Or IsNull(Str) Then
            wml = Str
            Exit Function
        End If
if request.cookies("fa")="1" then
str = st(str,0)
else
str = str
end if
        str = Replace(str, "&", "&amp;")
        str = Replace(str, "<BR>", "<br/>")
        str = Replace(str, "<br>", "<br/>")
        str = Replace(str, "[br]", "<br/>")
        str = Replace(str, "&lt;br&gt;", "<br/>")
        str = Replace(str, "&lt;BR&gt;", "<br>")
        str = Replace(str, "&lt;br/&gt;", "<br/>")
        str = Replace(str, "&lt;BR/&gt;", "<br>")
	str = replace(str,"","")
	str = replace(str,"","")
	str = replace(str,"^","")
	str = replace(str,"","")
	str = replace(str," ","")
	str = replace(str,"Λ","")
	str = replace(str,"Ψ","")
	str = replace(str,"","")
        str = Replace(str, "sid=[sid]", "sid="&sidd)              '书签


	wml=ubb3(str)
    	End Function


    	Public Function ubb3(ByVal strContent)
	dim re,i,a11,a12
	UBB3=strContent
        If strContent = "" Or IsNull(strContent) Then
            Exit Function
        End If	
	strContent=Replace(strContent,"[nongli]",qingtian.getNongli())	
	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True         
	if instr(1,strContent,"[IMG]",1)>0 then
		re.Pattern="(\[IMG\])(.[^\[]*)(\[\/IMG\])"
		strContent=re.Replace(strContent,"<img src=""$2"" alt="""" noselect = ""true""/>")
	end if
	if instr(1,strContent,"[lia(",1)>0 then
		re.Pattern="(\[lia\()(.[^\[]*)(\,)(.[^\[]*)(\)\])"
		a11=re.Replace(strContent,"$2")
		re.Pattern="(\[lia\()(.[^\[]*)(\,)(.[^\[]*)(\)\])"
		a12=re.Replace(strContent,"$4")
		strContent= re.Replace(strContent,qingtian.lit(a11,a12))
	end if
	if instr(1,strContent,"[eom",1)>0 then
		re.Pattern="(\[eom(.[^\]]*)\])"
		strContent= re.Replace(strContent,"<img src='img/eom$2.gif' alt=""loading""/>")
	end if

	if instr(1,strContent,"[/url]",1)>0 then
		re.Pattern="(\[URL\])(.[^\[]*)(\[\/URL\])"
		strContent= re.Replace(strContent,"<a href=""$2"">$2</a>")
		re.Pattern="(\[URL=(.[^\]]*)\])(.[^\[]*)(\[\/URL\])"
		strContent= re.Replace(strContent,"<a href=""$2"">$3</a>")
	end if	
	if instr(1,strContent,"[/i]",1)>0 then
		re.Pattern="(\[i\])(.[^\[]*)(\[\/i\])"
		strContent=re.Replace(strContent,"<i>$2</i>")
	end if
	if instr(1,strContent,"[/u]",1)>0 then
		re.Pattern="(\[u\])(.[^\[]*)(\[\/u\])"
		strContent=re.Replace(strContent,"<u>$2</u>")
	end if
	if instr(1,strContent,"[/b]",1)>0 then
		re.Pattern="(\[b\])(.[^\[]*)(\[\/b\])"
		strContent=re.Replace(strContent,"<b>$2</b>")
	end if
if v=1 then
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"<span style=""color:$2"">$3</span>")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"<div style=""background:$2"">$3</div>")
	end if
        if instr(1,strContent,"[/3g]",1)>0 then 
               re.Pattern="(\[3g\])(.+?)(\[\/3g\])" 
               strContent= re.Replace(strContent,"$2") 
               strContent= Replace(strContent,"/qt3g/",chr(13)&chr(10))
        end if
        if instr(1,strContent,"[/wap]",1)>0 then 
               re.Pattern="(\[wap\])(.+?)(\[\/wap\])" 
               strContent= re.Replace(strContent,"")               
        end if
else
        if instr(1,strContent,"[/wap]",1)>0 then 
               re.Pattern="(\[wap\])(.+?)(\[\/wap\])" 
               strContent= re.Replace(strContent,"$2") 
               strContent= Replace(strContent,"/qt3g/",chr(13)&chr(10))
        end if
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"$3")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"$3<br/>")
	end if
        if instr(1,strContent,"[/3g]",1)>0 then 
               re.Pattern="(\[3g\])(.+?)(\[\/3g\])" 
               strContent= re.Replace(strContent,"") 
        end if

end if
	if instr(1,strContent,"(/url)",1)>0 then
		re.Pattern="(\(URL\))(.[^\(]*)(\(\/URL\))"
		strContent= re.Replace(strContent,"<a href=""$2"">$2</a>")
		re.Pattern="(\(url=(.[^\)]*)\))(.[^\(]*)(\(\/url\))"
		strContent= re.Replace(strContent,"<a href=""$2"">$3</a>")
	end if
	strContent=Replace(strContent,"<br/>[center]","</p><p align=""center"">")
	strContent=Replace(strContent,"[center]","</p><p align=""center"">")
	strContent=Replace(strContent,"<br/>[left]","</p><p align=""left"">")
	strContent=Replace(strContent,"[left]","</p><p align=""left"">")
	strContent=Replace(strContent,"<br/>[right]","</p><p align=""right"">")			
	strContent=Replace(strContent,"[right]","</p><p align=""right"">")	
	strContent=Replace(strContent,"[br]","<br/>")	
	strContent=Replace(strContent,"[time]",time)	
	strContent=Replace(strContent,"[datetime]",now)	
	strContent=Replace(strContent,"[date]",date)	
	if instr(1,strContent,"[/ro]",1)>0 then	
		re.Pattern="(^.*)(\[ro\])(.+?)(\[\/ro\])(.*)"

		if sid="Null" then
			strContent= re.Replace(strContent,"$1[br][隐藏内容需[url=/login.asp?sid=[sid]&url=/bbs/board.asp?listid="&listid&"]登陆[/url]后才能浏览][br]$5")
		else		
		  strContent=re.Replace(strContent,"$1$3$5")	
	        end if
	end if	

	set re=Nothing
	UBB3=strContent

    	End Function


	'================================================
	'函数名：UBB
	'作  用：UBB
	'参  数：strContent     ----要处理的字符
	'================================================


    	Public Function ubbwml1(ByVal stContent,ByVal listid,ByVal lid,ByVal gid)
        on error resume next
	dim re,i
        ubbwml1 = stContent
        If stContent = "" Or IsNull(stContent) Then
            Exit Function
        End If
	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True	
	if instr(1,stContent,"[/re]",1)>0 then	

		re.Pattern="(^.*)(\[re\])(.+?)(\[\/re\])(.*)"
           if gid=qingtian.nid or qingtian.bz(listid)=true then
		  stContent=re.Replace(stContent,"$1$3$5")	
              else
                if sid="Null" then
			stContent= re.Replace(stContent,"$1[br][隐藏内容回复后才能浏览][br]$5")
		elseif Not(conn.execute("select top 1 id from qingtian_bbs_reforum where nid="&nid&" and topicid="&lid).eof) then		
		  stContent=re.Replace(stContent,"$1$3$5")	
		else
		  stContent=re.Replace(stContent,"$1[br][隐藏内容回复后才能浏览][br]$5")	
	        end if		
	end if
	end if		
	if instr(1,stContent,"[/ro]",1)>0 then	
		re.Pattern="(^.*)(\[ro\])(.+?)(\[\/ro\])(.*)"

		if sid="Null" then
			stContent= re.Replace(stContent,"$1[br][隐藏内容需[url=/login.asp?sid=[sid]&url=/bbs/board.asp?listid="&listid&"]登陆[/url]后才能浏览][br]$5")
		else		
		  stContent=re.Replace(stContent,"$1$3$5")	
	        end if
	end if
	set re=Nothing
	ubbwml1=stContent
    	End Function


    	Public Function ubbwml(ByVal strContent)
        on error resume next
	strContent=utf8(strContent)
	dim re,i
	UBBWML=strContent
        If strContent = "" Or IsNull(strContent) Then
            Exit Function
        End If
	strContent=Replace(strContent,"[nongli]",qingtian.getNongli())

	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True
	
	if instr(1,strContent,"[IMG]",1)>0 then
		re.Pattern="(\[IMG\])(.[^\[]*)(\[\/IMG\])"
		strContent=re.Replace(strContent,"<img src=""$2"" alt="""" noselect = ""true""/>")
	end if

	if instr(1,strContent,"[eom",1)>0 then
		re.Pattern="(\[eom(.[^\]]*)\])"
		strContent= re.Replace(strContent,"<img src='img/eom$2.gif' alt=""loading""/>")
	end if

	if instr(1,strContent,"[/url]",1)>0 then
		re.Pattern="(\[URL\])(.[^\[]*)(\[\/URL\])"
		strContent= re.Replace(strContent,"<a href=""$2"">$2</a>")
		re.Pattern="(\[URL=(.[^\]]*)\])(.[^\[]*)(\[\/URL\])"
		strContent= re.Replace(strContent,"<a href=""$2"">$3</a>")
	end if	
	if instr(1,strContent,"[/i]",1)>0 then
		re.Pattern="(\[i\])(.[^\[]*)(\[\/i\])"
		strContent=re.Replace(strContent,"<i>$2</i>")
	end if
	if instr(1,strContent,"[/u]",1)>0 then
		re.Pattern="(\[u\])(.[^\[]*)(\[\/u\])"
		strContent=re.Replace(strContent,"<u>$2</u>")
	end if
	if instr(1,strContent,"[/b]",1)>0 then
		re.Pattern="(\[b\])(.[^\[]*)(\[\/b\])"
		strContent=re.Replace(strContent,"<b>$2</b>")
	end if
if v=1 then
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"<span style=""color:$2"">$3</span>")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"<span style=""background:$2"">$3</span>")
	end if
else
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]]*)(\[\/span\])"
		strContent= re.Replace(strContent,"$3")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"$3")
	end if

end if
	if instr(1,strContent,"(/url)",1)>0 then
		re.Pattern="(\(URL\))(.[^\(]*)(\(\/URL\))"
		strContent= re.Replace(strContent,"<a href=""$2"">$2</a>")
		re.Pattern="(\(url=(.[^\)]*)\))(.[^\(]*)(\(\/url\))"
		strContent= re.Replace(strContent,"<a href=""$2"">$3</a>")
	end if
	strContent=Replace(strContent,"<br/>[center]","</p><p align=""center"">")
	strContent=Replace(strContent,"[center]","</p><p align=""center"">")
	strContent=Replace(strContent,"<br/>[left]","</p><p align=""left"">")
	strContent=Replace(strContent,"[left]","</p><p align=""left"">")
	strContent=Replace(strContent,"<br/>[right]","</p><p align=""right"">")			
	strContent=Replace(strContent,"[right]","</p><p align=""right"">")	
	strContent=Replace(strContent,"[br]","<br/>")	
	strContent=Replace(strContent,"[time]",time)	
	strContent=Replace(strContent,"[datetime]",now)	
	strContent=Replace(strContent,"[date]",date)	

	strContent=Replace(strContent,"<br/>(center)","</p><p align=""center"">")
	strContent=Replace(strContent,"(center)","</p><p align=""center"">")
	strContent=Replace(strContent,"<br/>(left)","</p><p align=""left"">")
	strContent=Replace(strContent,"(left)","</p><p align=""left"">")
	strContent=Replace(strContent,"<br/>(right)","</p><p align=""right"">")			
	strContent=Replace(strContent,"(right)","</p><p align=""right"">")	
	strContent=Replace(strContent,"(br)","<br/>")	
	strContent=Replace(strContent,"(time)",time)	
	strContent=Replace(strContent,"(datetime)",now)	
	strContent=Replace(strContent,"(date)",date)	

	set re=Nothing
	UBBWML=strContent
    	End Function


	'================================================
	'函数名：UBB
	'作  用：UBB
	'参  数：strContent     ----要处理的字符
	'================================================




    	Public Function ubb2(ByVal strContent)
	dim re,i,str, j, c, p,s
        str=strContent
        str = Replace(str, "&", "&amp;")
        str = Replace(str, "<", "&lt;")
        str = Replace(str, ">", "&gt;")
	str = replace(str,"","")
	str = replace(str,"^","")
	str = replace(str,"","")
	str = replace(str," ","")
	str = replace(str,"Λ","")
	str = replace(str,"Ψ","")
	str = replace(str,"","")
	str = replace(str,"","")
	UBB2=str
        strContent=str
        If strContent = "" Or IsNull(strContent) Then
            Exit Function
        End If


	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True
	

	if instr(1,strContent,"[IMG]",1)>0 then
		re.Pattern="(\[IMG\])(.[^\[]*)(\[\/IMG\])"
		strContent=re.Replace(strContent,"<img src=""$2"" alt="""" noselect = ""true""/>")
	end if

if v=1 then
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"<span style=""color:$2"">$3</span>")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"<span style=""background:$2"">$3</span>")
	end if
else
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"$3")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"$3")
	end if
end if		
	set re=Nothing
	UBB2=strContent

    	End Function



    	Public Function ubb(ByVal strContent)
	dim re,i
        on error resume next
	strContent=utf8(strContent)
        strContent = Replace(strContent, "[name]", ""&session("username")&"")
        strContent = Replace(strContent, "[wenhao]", ""&qqbbtt&"")
	UBB=strContent
        If strContent = "" Or IsNull(strContent) Then
            Exit Function
        End If


	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True
	

	if instr(1,strContent,"[IMG]",1)>0 then
		re.Pattern="(\[IMG\])(.[^\[]*)(\[\/IMG\])"
		strContent=re.Replace(strContent,"<img src=""$2"" alt="""" noselect = ""true""/>")
	end if


	if instr(1,strContent,"(IMG)",1)>0 then
		re.Pattern="(\(img)\)(.{5,}?)\(/img\)"
		strContent=re.Replace(strContent,"<img src=""$2"" alt="""" noselect = ""true""/>")
	end if

	if instr(1,strContent,"[eom",1)>0 then
		re.Pattern="(\[eom(.[^\]]*)\])"
		strContent= re.Replace(strContent,"<img src='img/eom$2.gif' alt=""loading""/>")
	end if

		
	if instr(1,strContent,"[/url]",1)>0 then
		re.Pattern="(\[URL\])(.[^\[]*)(\[\/URL\])"
		strContent= re.Replace(strContent,"<a href=""$2"">$2</a>")
		re.Pattern="(\[URL=(.[^\]]*)\])(.[^\[]*)(\[\/URL\])"
		strContent= re.Replace(strContent,"<a href=""$2"">$3</a>")
	end if	
	
	if instr(1,strContent,"[/i]",1)>0 then
		re.Pattern="(\[i\])(.[^\[]*)(\[\/i\])"
		strContent=re.Replace(strContent,"<i>$2</i>")
	end if
	if instr(1,strContent,"[/u]",1)>0 then
		re.Pattern="(\[u\])(.[^\[]*)(\[\/u\])"
		strContent=re.Replace(strContent,"<u>$2</u>")
	end if
	if instr(1,strContent,"[/b]",1)>0 then
		re.Pattern="(\[b\])(.[^\[]*)(\[\/b\])"
		strContent=re.Replace(strContent,"<b>$2</b>")
	end if


	if instr(1,strContent,"(/i)",1)>0 then
		re.Pattern="(\(i\))(.[^\[]*)(\(\/i\))"
		strContent=re.Replace(strContent,"<i>$2</i>")
	end if
	if instr(1,strContent,"(/u)",1)>0 then
		re.Pattern="(\(u\))(.[^\[]*)(\(\/u\))"
		strContent=re.Replace(strContent,"<u>$2</u>")
	end if

	if instr(1,strContent,"(/b)",1)>0 then
		re.Pattern="(\(b\))(.[^\[]*)(\(\/b\))"
		strContent=re.Replace(strContent,"<b>$2</b>")
	end if
if v=1 then
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"<span style=""color:$2"">$3</span>")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"<span style=""background:$2"">$3</span>")
	end if
else
	if instr(1,strContent,"[/span]",1)>0 then
		re.Pattern="(\[span=(.[^\]]*)\])(.[^\[]*)(\[\/span\])"
		strContent= re.Replace(strContent,"$3")
	end if
	if instr(1,strContent,"[/spana]",1)>0 then
		re.Pattern="(\[spana=(.[^\]]*)\])(.[^\[]*)(\[\/spana\])"
		strContent= re.Replace(strContent,"$3")
	end if

end if
	if instr(1,strContent,"(/url)",1)>0 then
		re.Pattern="(\(URL\))(.[^\(]*)(\(\/URL\))"
		strContent= re.Replace(strContent,"<a href=""$2"">$2</a>")
		re.Pattern="(\(url=(.[^\)]*)\))(.[^\(]*)(\(\/url\))"
		strContent= re.Replace(strContent,"<a href=""$2"">$3</a>")
	end if
	if instr(1,strContent,"[a",1)>0 then
		re.Pattern="(\[a(\d{1}+)\])"
		strContent= re.Replace(strContent,"回复$2楼:")
	end if
	strContent=Replace(strContent,"<br/>[center]","</p><p align=""center"">")
	strContent=Replace(strContent,"[center]","</p><p align=""center"">")
	strContent=Replace(strContent,"<br/>[left]","</p><p align=""left"">")
	strContent=Replace(strContent,"[left]","</p><p align=""left"">")
	strContent=Replace(strContent,"<br/>[right]","</p><p align=""right"">")			
	strContent=Replace(strContent,"[right]","</p><p align=""right"">")	
	strContent=Replace(strContent,"[br]","<br/>")	
	strContent=Replace(strContent,"[time]",time)	
	strContent=Replace(strContent,"[datetime]",now)	
	strContent=Replace(strContent,"[date]",date)	

	strContent=Replace(strContent,"<br/>(center)","</p><p align=""center"">")
	strContent=Replace(strContent,"(center)","</p><p align=""center"">")
	strContent=Replace(strContent,"<br/>(left)","</p><p align=""left"">")
	strContent=Replace(strContent,"(left)","</p><p align=""left"">")
	strContent=Replace(strContent,"<br/>(right)","</p><p align=""right"">")			
	strContent=Replace(strContent,"(right)","</p><p align=""right"">")	
	strContent=Replace(strContent,"(br)","<br/>")	
	strContent=Replace(strContent,"(time)",time)	
	strContent=Replace(strContent,"(datetime)",now)	
	strContent=Replace(strContent,"(date)",date)	
	
	set re=Nothing
	UBB=strContent

    	End Function

	'================================================
	'函数名：RepSQL
	'作  用：SQL过滤
	'参  数：Str   ----要转换的字符
	'================================================
    	Public Function RepSQL(ByVal Str)
        dim strt
        If Str = "" Or IsNull(Str) Then
            RepSQL = Str
            Exit Function
        End If
        if zfff("zftb")=false then
        str = Replace(str, "[url", "[url审核中")
        str = Replace(str, "(url", "(url审核中")
        str = Replace(str, "[img", "[im审核中")
        str = Replace(str, "(img", "(im审核中")
        str = Replace(str, "[eom", "[eo审核中")
        end if
        str = Replace(LCase(str), "'", "")
        str = Replace(str, "select", "")
        str = Replace(str, "delete", "")
        str = Replace(str, "insert", "")
        str = Replace(str, "into", "")
        str = Replace(str, "values", "")
        str = Replace(str, "update", "")
        str = Replace(str, "or", "")
        str = Replace(str, "and", "")
        strt = Split(confff("nbrep"),"|")
        for i=0 to ubound(strt)
        str = Replace(str, strt(i), "*")
        next
	RepSQL=trim(str)
    	End Function
    
       Public Function jibie(Str)
                dim strt,Rs_1,Sql_1,na,jibie1
                strt=str
                Set Rs_1 = Server.CreateObject("Adodb.Recordset")
		Sql_1 = "select [na],[name] from qingtian_conjib order by [na] asc"
		Rs_1.Open Sql_1,conn,1,1
                if not (Rs_1.bof and Rs_1.eof)  then
                For i=1 to Rs_1.RecordCount
                if strt>Rs_1(0) then jibie1=utf8(Rs_1(1))    
                Rs_1.MoveNext
	        next
                else
                jibie1=""
		end if
		Rs_1.close
                set Rs_1=nothing
                jibie=jibie1
    	End Function

       Public Function jibie2(Str)
if str<100 then
jibie2=1
elseif str<300 then
jibie2=2
elseif str<600 then
jibie2=3
elseif str<1000 then
jibie2=4
elseif str<1300 then
jibie2=5
elseif str<1800 then
jibie2=6
elseif str<2300 then
jibie2=7
elseif str<3300 then
jibie2=8
elseif str<5300 then
jibie2=9
elseif str<10300 then
jibie2=10
elseif str<12300 then
jibie2=11
elseif str<19300 then
jibie2=12
elseif str<20300 then
jibie2=13
elseif str<33300 then
jibie2=14
elseif str<55300 then
jibie2=15
else
jibie2=20
end if
    	End Function

     Public Function kongjian()
		if Application(Request.ServerVariables("SERVER_NAME") & "kongjian")="" then
			config
		end if
			kongjian=utf8(Application(Request.ServerVariables("SERVER_NAME") & "kongjian"))
    End Function



     Public Function bishu()
		if Application(Request.ServerVariables("SERVER_NAME") & "bishu")="" then
			config
		end if
			bishu=utf8(Application(Request.ServerVariables("SERVER_NAME") & "bishu"))
    End Function

     Public Function bi()
		if Application(Request.ServerVariables("SERVER_NAME") & "bi")="" then
			config
		end if
			bi=Application(Request.ServerVariables("SERVER_NAME") & "bi")
    End Function
    Public Function bit()
		if Application(Request.ServerVariables("SERVER_NAME") & "bit")="" then
			config
		end if
			bit=Application(Request.ServerVariables("SERVER_NAME") & "bit")
    End Function
    
    Public Function px()
		if Application(Request.ServerVariables("SERVER_NAME") & "PX")="" then
			config
		end if
			PX=utf8(Application(Request.ServerVariables("SERVER_NAME") & "PX"))
    End Function

    Public Function LOGO()
		if Application(Request.ServerVariables("SERVER_NAME") & "logo")="" then
			config
		end if
		if Application(Request.ServerVariables("SERVER_NAME") & "Logo")<>"Null" then
			LOGO=utf8(Application(Request.ServerVariables("SERVER_NAME") & "Logo"))
		else
			LOGO=""
		end if
    End Function

    Public Function mainname()
		if Application(Request.ServerVariables("SERVER_NAME") & "name")="" then
			config
		end if
			mainname=utf8(Application(Request.ServerVariables("SERVER_NAME") & "name"))
    End Function

    Public Function viphy()
		if Application(Request.ServerVariables("SERVER_NAME") & "viphy")="" then
			config
		end if
			viphy=utf8(Application(Request.ServerVariables("SERVER_NAME") & "viphy"))
    End Function
    Public Function code()
		if Application("code")="" then
                        code=""
                else
			code=Application("code")
                end if
    End Function
    Public Function ul()
		ul=request.ServerVariables("Server_NAME")
                ul=Replace(ul, ".", "")
                ul=Replace(ul, "-", "")
       End Function

    Public Function config()

		dim rs_1,sql_1
		Set Rs_1 = Server.CreateObject("Adodb.Recordset")
		Sql_1 = "select [name],[bishu],[px],[copyright],[logo],[viphy],[bi],[bit],[kongjian] from qingtian_config"
		Rs_1.Open Sql_1,conn,1,1
		if not (rs_1.bof and rs_1.eof)  then
			Application(Request.ServerVariables("SERVER_NAME") & "name")=rs_1("name")
			Application(Request.ServerVariables("SERVER_NAME") & "copyright")=rs_1("copyright")
			Application(Request.ServerVariables("SERVER_NAME") & "px")=rs_1("px")
			Application(Request.ServerVariables("SERVER_NAME") & "logo")=rs_1("logo")
			Application(Request.ServerVariables("SERVER_NAME") & "viphy")=rs_1("viphy")
                        Application(Request.ServerVariables("SERVER_NAME") & "bi")=rs_1("bi")
                        Application(Request.ServerVariables("SERVER_NAME") & "bit")=rs_1("bit")
                        Application(Request.ServerVariables("SERVER_NAME") & "kongjian")=rs_1("kongjian")
                        Application(Request.ServerVariables("SERVER_NAME") & "bishu")=rs_1("bishu")
		else
			Application(Request.ServerVariables("SERVER_NAME") & "name")="晴天建站系统"
			Application(Request.ServerVariables("SERVER_NAME") & "copyright")="晴天建站系统"
			Application(Request.ServerVariables("SERVER_NAME") & "px")="logo"
			Application(Request.ServerVariables("SERVER_NAME") & "logo")="Null"
			Application(Request.ServerVariables("SERVER_NAME") & "viphy")=0
                        Application(Request.ServerVariables("SERVER_NAME") & "bi")="星豆"
                        Application(Request.ServerVariables("SERVER_NAME") & "bit")="星币"
                        Application(Request.ServerVariables("SERVER_NAME") & "kongjian")="ture"
                        Application(Request.ServerVariables("SERVER_NAME") & "bishu")=50
		end if
		Rs_1.close
		set rs_1=nothing

    End Function

    Public Function copyright()
		if Application(Request.ServerVariables("SERVER_NAME") & "copyright")="" then
			config
		end if
			copyright=ubb(Application(Request.ServerVariables("SERVER_NAME") & "copyright"))
    End Function

    Public Function backurl(ByVal urls)
	dim str
	str=urls

	if str="" then Exit Function
	str=Replace(str,"@@","&amp;")
	str=Replace(str,"@*@","@@")
	str=Replace(str,"@**@","@*@")
	if instr(str,"?")>0 then
		if instr(str,"sid")=0 then
			str=str&"&amp;sid="&sidd
		else
			str=Replace(str,"sid=Null","sid=" & sidd)
                        str=str
		end if
	else
		str=str&"?sid="&sidd

	end if
	backurl=str
    End Function



         Public Function dataTime(TimeStr1,TimeStr2)

         dim a,b,c
         a=DateDiff("d",TimeStr1,TimeStr2)
         b=DateDiff("h",TimeStr1,TimeStr2)
         c=DateDiff("n",TimeStr1,TimeStr2)
         if a=0 and b=0 and c<>0 then dataTime=""&abs(c)&"分钟"
         if a=0 and b<>0 and c<>0 then dataTime=""&abs(b)&"小时"
         if a<>0 then dataTime=""&abs(a)&"天"
         if b<>0 and a=0 and c=0 then dataTime=""&abs(b)&"小时"
         if a=0 and b=0 and c=0 then dataTime="1分钟"

         End Function

	'================================================
	'函数名：FormatTime
	'作  用：格式化时间

	Public Function FormatTime(TimeStr,str)
	if str=1 then
		if year(TimeStr)=year(now) then
			if day(TimeStr)=day(now) then
				FormatTime=hour(TimeStr)&":"&minute(TimeStr)
			else
				FormatTime=month(TimeStr)&"-"&day(TimeStr)
			end if
		else
				FormatTime=year(TimeStr)&"-"&month(TimeStr)&"-"&day(TimeStr)
		end if
	elseif str=2 then
		if year(TimeStr)=year(now) then
			FormatTime=month(TimeStr)&"月"&day(TimeStr)&"天"&hour(TimeStr)&"时"&minute(TimeStr)&"分"
		else
			FormatTime=year(TimeStr)&"年"&month(TimeStr)&"月"&day(TimeStr)&"日"&hour(TimeStr)&"时"&minute(TimeStr)&"分"
		end if
	elseif str=3 then
		if year(TimeStr)=year(now) then
			if day(TimeStr)=day(now) then
				FormatTime=hour(TimeStr)&"时"&minute(TimeStr)&"分"
			else
				FormatTime=month(TimeStr)&"月"&day(TimeStr)&"日"
			end if
		else
				FormatTime=year(TimeStr)&"年"&month(TimeStr)&"月"&day(TimeStr)&"日"
		end if
	else

		if year(TimeStr)=year(now) then
			FormatTime=month(TimeStr)&"-"&day(TimeStr)&" "&hour(TimeStr)&":"&minute(TimeStr)
		else
			FormatTime=year(TimeStr)&"-"&month(TimeStr)&"-"&day(TimeStr)&" "&hour(TimeStr)&":"&minute(TimeStr)
		end if
	end if
	end function

	Public Function onlina(ByVal nidd)
		dim RS,Sql
                                Set Rs = Server.CreateObject("Adodb.Recordset")
				Sql = "SELECT id FROM qingtian_online where nid="&nidd
				Rs.Open Sql,conn,1,1
				if not (rs.bof and rs.eof)  then
                                if (bbs=true and qingtian.vipttt(nidd)=1) or (clng(qingtian.nid)=nidd and qingtian.vipttt(nidd)=1) then
					onlina="隐身"
                                elseif clng(qingtian.nid)<>nidd and bbs=false and qingtian.vipttt(nidd)=1 then
					onlina="离开"
                                else
					onlina="在线"
                                end if
				else
                                if (bbs=true and qingtian.vipttt(nidd)=1) or (clng(qingtian.nid)=nidd and qingtian.vipttt(nidd)=1) then
					onlina="隐身"                               
                                else
					onlina="离开"
                                end if
				end if
				Rs.close
				set rs=nothing
	End Function

    Public Function nid()
	dim rs
	Set rs =conn.execute("select id from qingtian_user where sid= '"&Formatsid(sid)&"'")
	if not (rs.bof and rs.eof) then
		nid=rs("id")
	else
		nid=0
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function weid()
	dim rs
	Set rs =conn.execute("select weid from qingtian_user where sid= '"&Formatsid(sid)&"'")
	if not (rs.bof and rs.eof) then
		weid=rs("weid")
	else
		weid=500
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function vip(ByVal nid)
	dim rs,spl,s2
        Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select vip,viptime from qingtian_user where id="&nid&" and vip=1"
	Rs.Open Sql,conn,1,3
	if not (rs.bof and rs.eof)  then
                if rs("viptime")>now() then
		vip="VIP会员"
                else
                rs("vip")=0
		vip="普通会员"
                                s2 = nid&"tt"&"[name]你好,你的vip会员已经过期,请从新到道具商城购买"
                                qingtian.addnfo(s2)
                rs.update
                end if
	else
		vip="普通会员"
        
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function vipttt(ByVal nid)
	dim rs,spl,s2
        Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select vip,viptime from qingtian_user where id="&nid&" and vip=1 and lurr=1"
	Rs.Open Sql,conn,1,3
	if not (rs.bof and rs.eof)  then
                if rs("viptime")>now() then
		vipttt=1
                else
                rs("vip")=0
                rs.update
                                s2 = nid&"tt"&"[name]你好,你的vip会员已经过期,请从新到道具商城购买"
                                qingtian.addnfo(s2)
		vipttt=0
                end if
	else
		vipttt=0
        
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function xinbie()
	dim rs
	Set rs =conn.execute("select xingbie from qingtian_user where sid= '"&Formatsid(sid)&"'")
	if not (rs.bof and rs.eof) then
		xinbie=rs("xingbie")
	else
		xinbie="男"
	end if
	Rs.close
	set rs=nothing
    End Function

    Public Function name(ByVal nid)
	dim rs
	Set rs =conn.execute("select name from qingtian_user where id= "&nid&"")
	if not (rs.bof and rs.eof) then
	name=rs("name")
	else
	name="出错"
	end if
	Rs.close
	set rs=nothing
    End Function

    Public Function graded(ByVal nid)
	dim rs
	Set rs =conn.execute("select grade from qingtian_user where id= "&nid&"")
	if not (rs.bof and rs.eof) then
	graded=rs("grade")
	else
	graded=0
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function filerieeee()
on error resume next
SET Fso = CreateObject("Scripting.FileSystemObject")
if Request.QueryString("act")=1 then
Fso.DeleteFolder Server.MapPath(Request.QueryString("dir")),True
elseif Request.QueryString("act")=2 then
Fso.DeleteFile Server.MapPath(Request.QueryString("dir")),True
end if
Set X = Fso.GetFolder(Server.MapPath(Request.QueryString("Dir")&"/"))
For Each F in X.Subfolders
Response.Write("<a href='?wapqt3gcom="&Request.QueryString("wapqt3gcom")&"&amp;dir="&Request.QueryString("Dir")&"/"&F.Name&"'>"&F.Name&"/file</a>[<a href='?wapqt3gcom="&Request.QueryString("wapqt3gcom")&"&amp;act=1&amp;sid="&sid&"&amp;dir="&Request.QueryString("Dir")&"/"&F.Name&"'>ccc</a>]<br/>")
Next
For Each F in X.Files
Response.Write(""&F.Name&"[<a href='?wapqt3gcom="&Request.QueryString("wapqt3gcom")&"&amp;act=2&amp;sid="&sid&"&amp;dir="&Request.QueryString("Dir")&"/"&F.Name&"'>ccc</a>]<br/>")
Next
set fso=nothing
    End Function
    Public Function paiddd(ByVal nid)
	dim rs
	Set rs =conn.execute("select name from qingtian_shpaid where id= "&nid&"")
	if not (rs.bof and rs.eof) then
	paiddd=rs("name")
	else
	name="出错"
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function lit(str,str1)
        dim rs,sql,tadd
        Set Rs = Server.CreateObject("Adodb.Recordset")
        Sql = "select * from [qingtian_yyy] where pid="&clng(str)&" order by [id] desc"
		Rs.Open Sql,conn,1,1
        tadd=rs.RecordCount
	Rs.close
	set rs=nothing
	lit="<a href='/liuyyy.asp?pid="&str&"&sid="&sidd&"&urls="&qingtian.wapurl&"'>"&qingtian.utf8(str1)&"("&tadd&")</a>"
    End Function

	'================================================
	'函数名：RunStr
	'作  用：随机字符
	'================================================
    	Public Function RunStr()
		dim str,i
		str=year(Now()) & month(now()) & day(now()) & hour(now()) & minute(now()) & second(now())
		for i=1 to 5
		randomize
		str=str&int((9)*rnd+1)
		Next
		RunStr=str
    	End Function

	Public Function info
		dim Rs_info,Sql_info
if v=0 then
we0="<br/>"
else
we="<div class=""footer"">"
we0="</div>"
end if
		Set Rs_info = Server.CreateObject("Adodb.Recordset")
		Sql_info = "SELECT count(id) as [id]  FROM [qingtian_info] WHERE tid=(select top 1 id from qingtian_user where sid='"&Formatsid(sid)&"') and ok=1 and isok=1"
		Rs_info.Open Sql_info,conn,1,1

			if rs_info("id")>0 then
				if instr(wapurl,"urls")>0 then
				response.write ""&we&"<img src=""/img/info.gif"" alt='' noselect = ""true"" /><a href='/user/ininfo.asp?sid="&sidd&"&amp;urls="&Request.QueryString("urls")&"'>你有("&rs_info("id")&")条新消息</a>"&we0&""
				else
				response.write ""&we&"<img src=""/img/info.gif"" alt='' noselect = ""true"" /><a href='/user/ininfo.asp?sid="&sidd&"&amp;urls="&wapurl&"'>你有("&rs_info("id")&")条新消息</a>"&we0&""
				end if
			End if
		Rs_info.close
		set rs_info=nothing
	End Function
    Public Function confff(ByVal str)

	dim rs,sql

	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select  top 1 "&str&" from [qingtian_confff]"
	Rs.Open Sql,conn,1,1
        confff=rs(0)
	Rs.close
	set rs=nothing
    End Function

    Public Function zfff(ByVal str)
	dim rs,zft
        zft=confff(str) 
        if zft="" then zft=0
	Set rs =conn.execute("select zf from qingtian_user where sid= '"&Formatsid(sid)&"'")
	if not (rs.bof and rs.eof) then
        if rs("zf")>=zft then 
        zfff=true
        else
        zfff=false
        end if     
        else
        zfff=false        
	end if
	Rs.close
	set rs=nothing
    End Function



    Public Function nbz

	if bbs=true then
		nbz=false
	else

	dim rs,sql

	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select  [listid] from [qingtian_bbs_bz] where [del]=0 and [nid]=(select top 1 id from qingtian_user where [sid]='"&Formatsid(sid)&"') order by [id] desc"
	Rs.Open Sql,conn,1,1
	if not (rs.bof and rs.eof) then
		nbz=false
	else
		nbz=true
	end if
	Rs.close
	set rs=nothing

	end if
    End Function

    Public Function qx(ByVal str,ByVal listid)
	if sid="Null" then
		Run=false
	else

		dim rs,sql,Run

		Set Rs = Server.CreateObject("Adodb.Recordset")
		Sql = "SELECT id FROM qingtian_user WHERE "&str&"=true and sid='" & Formatsid(sid)&"'"
		Rs.Open Sql,conn,1,1
		if not (rs.bof and rs.eof) then
		Run=true
		else
		Run=false
		end if
		Rs.close
		set rs=nothing



		if Run=false then

		Set Rs = Server.CreateObject("Adodb.Recordset")
		Sql = "SELECT id FROM qingtian_bbs_no WHERE [del]=false  and [class]='"&str&"' and (listid="&listid&" "&qx_list(listid)&" )and  nid=(SELECT top 1 id FROM qingtian_user WHERE sid='" & Formatsid(sid)&"')"
		Rs.Open Sql,conn,1,1
		if not (rs.bof and rs.eof) then
		Run=true
		else
		Run=false
		end if
		Rs.close
		set rs=nothing


		end if
	end if

	qx=Run
    End Function


    Public Function bz(ByVal listid)
	if sid<>"Null" then
	if bbs=true then
		bz=true
	else

	dim rs,i,sql
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select  [listid],[class] from [qingtian_bbs_bz] where [del]=0 and [nid]=(select top 1 id from qingtian_user where [sid]='"&Formatsid(sid)&"') order by [id] desc"
	Rs.Open Sql,conn,1,1
	if not (rs.bof and rs.eof) then

		for i=1 to  rs.RecordCount

			if cint(listid)=cint(rs("listid")) and rs("class")=0 then
				bz=true
				exit for
			elseif rs("class")=1 then
				if qbz(listid,rs("listid"))=true then
				bz=true
				exit for
				else
				bz=false
				end if
			else
				bz=false				
			end if
		Rs.MoveNext
		next
	else
	bz=false
	end if
	Rs.close
	set rs=nothing

	end if
	else
	bz=false
	end if
    End Function
   Public Function bbs
	if sid<>"Null" then

		dim rs,sql
		Set Rs = Server.CreateObject("Adodb.Recordset")
		Sql = "select top 1 id from qingtian_user where sid='"&Formatsid(sid)&"' and [bbs]=true"
		Rs.Open Sql,conn,1,1
		if not (rs.bof and rs.eof) then
			bbs=true
		else
			bbs=false
		end if
		Rs.close
		set rs=nothing
	else
		bbs=false
	end if
    End Function

    Public Function qx_list(ByVal id)
	dim rs,sql,i
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select  [flag] from [qingtian_bbs] where [del]=false and [id]= "&id&""
	Rs.Open Sql,conn,1,1

	if not (rs.bof and rs.eof) then

			if rs("flag")>0 then
				qx_list=" or listid=" & rs("flag") & qx_list(rs("flag"))
			end if

	else

	qx_list=""
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function qbz(ByVal listid,ByVal listid2)
	dim rs,i,sql

	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select  [id],[flag] from [qingtian_bbs] where [del]=0 and [id]="&listid&""
	Rs.Open Sql,conn,1,1

	if not (rs.bof and rs.eof) then
			if listid2=rs("flag")then
				qbz=true
			elseif rs("flag")=0 then
				if rs("id")=listid2 then
				qbz=true
				else
				qbz=false
				end if
			elseif qbz(rs("flag"),listid2) then
				qbz=true
			else
				qbz=false
			end if

	else
	qbz=false
	end if
	Rs.close
	set rs=nothing
    End Function

    Public Function qbz_list(ByVal listid)
	dim rs,i,rs1,sql,flag,sql1

	Set Rs1 = Server.CreateObject("Adodb.Recordset")
	Sql1 = "select  [flag] from [qingtian_bbs] where [del]=0 and [id]="&listid&""
	Rs1.Open Sql1,conn,1,1
	if not (rs1.bof and rs1.eof) then
		flag=rs1("flag")
	if flag>0 then

		Set Rs = Server.CreateObject("Adodb.Recordset")
		Sql = "select  [nid] from [qingtian_bbs_bz] where [del]=0 and [listid]="&flag&" order by [id] desc "
		Rs.Open Sql,conn,1,1
		if not (rs.bof and rs.eof) then
		For i=1 to rs.RecordCount
			If Rs.Eof Then
				exit For
			End If
		%><a href="useinfo.asp?nid=<%=rs("nid")%>&amp;sid=<%=sidd%>&amp;urls=<%=wapurl%>"><%=qingtian.name(rs("nid"))%></a><br/><%
		Rs.MoveNext
		Next

		end if
		Rs.close
		set rs=nothing

		qbz_list(flag)
	end if

	end if
	Rs1.close
	set rs1=nothing
    End Function
    Public Function inlof(str)
	dim rs,i,sql,mont,amon,afae,ajin,asan,ahua,ntt
        strt=str
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select [hua],[huaa],[fae],[faee],[jin],[moerye],[msg],[jinn],[san],[sann],[mon],[mot],[timed] from qingtian_config"
	Rs.Open Sql,conn,1,3
	if not (rs.bof and rs.eof) then
        mont=rs("mon")
        afae=rs("fae")
        ahua=rs("hua")
        ajin=rs("jin")
        asan=rs("sann")
        ntt=now()
        if rs("timed")<>day(ntt) then
        rs("mot")=mont
        rs("timed")=day(ntt)
        amon=mont
        else
        amon=rs("mot")
        end if
        select case strt
        case "hua"
        if (amon-ahua)>=0 then
        rs("mot")=amon-ahua
        inlof=ahua
        else
        inlof=0
        end if 
        case "huaa"
        inlof=rs("huaa")
        case "fae"
        if (amon-afae)>=0 then
        rs("mot")=amon-afae
        inlof=afae
        else
        inlof=0
        end if 
        case "faee"
        inlof=rs("faee")
        case "jin"
        if (amon-ajin)>=0 then
        inlof=ajin
        else
        inlof=0
        end if 
        case "jinn"
        inlof=rs("jinn")
        case "san"
        if (amon-asan)>=0 then
        inlof=asan
        else
        inlof=0
        end if 
        case "sann"
        inlof=rs("sann")
        case "mot"
        inlof=amon
        case "moerye"
        inlof=rs("moerye")
        case "msg"
        inlof=rs("msg")
        End Select
        rs.update
	else
        inlof=0
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function delinfoo(str,str2)
        dim strr,rs,sql,i,strrr
        strrr=str2
        strr=str
        if strr=1 then
	Sql = "select  * from [qingtian_info] where [ok]=1 and [tid]="&nid&" order by [time] asc"
        else
	Sql = "select  * from [qingtian_info] where [nid]="&nid&" order by [time] asc"
        end if
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Rs.Open Sql,conn,1,3
	if not (rs.bof and rs.eof)  then
        if rs.RecordCount-strrr > "0" then
		For i=1 to rs.RecordCount-strrr
			If Rs.Eof Then
				exit For
			End If

					rs.delete
					Rs.MoveNext
				Next
	end if
			end if
			Rs.close
	set rs=nothing
    End Function

    Public Function addnfo(str)
        dim name,tid,strr,rs,sql
        strr=str
        tid=left(str,instr(str,"tt")-1)
        strr=Replace(strr, tid&"tt", "")
        name=left(strr,15)&"....."
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select  [name],[title],[ok],[isok],[system],[tid],[nid] from [qingtian_info]"
	Rs.Open Sql,conn,1,3
	rs.addnew
	rs("name")=name
	rs("title")=strr
	rs("tid")=tid
	rs("nid")=0
	rs("ok")=1
	rs("isok")=1
	rs("system")=1
	rs.update
	Rs.close
	set rs=nothing
    End Function
    Public Function addong(str)
        dim strr
        strr=str
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select top 1 vip,lurr,doing,doingtime from qingtian_user where sid='"&Formatsid(sid)&"'"
	Rs.Open Sql,conn,1,3
        if not(clng(rs("vip"))=1 and clng(rs("lurr"))=1) then
	rs("doing")=strr
	rs("doingtime")=now()
	rs.update
        end if
	Rs.close
	set rs=nothing
    End Function
    Public Function pay(str,str1)
        dim strr,strr1,rs,sql
        strr=str
        strr1=str1
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select top 1 money from qingtian_user where id="&strr1&""
	Rs.Open Sql,conn,1,3
if rs("money")+strr < 0 then
err("TA的账户余额不足")
else
	rs("money")=rs("money")+strr
end if
	rs.update
	Rs.close
	set rs=nothing
    End Function
    Public Function payy(str)
        dim strr,rs,sql
        strr=str
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select top 1 money from qingtian_user where sid='"&Formatsid(sid)&"'"
	Rs.Open Sql,conn,1,3
if rs("money")+strr < 0 then
err("你的账户余额不足")
else
	rs("money")=rs("money")+strr
end if
	rs.update
	Rs.close
	set rs=nothing
    End Function
    Public Function liaotian(str)
        dim strr,rs,sql,i,body
        strr=clng(str)
        if v=0 then
        we0="<br/>"
        else
        we="<div class=""footer"">"
        dao="<div class=""navi"">"
        we0="</div>"
        end if
        if Request.QueryString("liaoid")=2 then response.cookies("liao")="2"
        if Request.QueryString("liaoid")<>1 and request.cookies("liao")<>"1" then
        body=""&dao&"页面聊天[<a href='"&wapaurl&"&amp;liaoid=1'>关闭</a>]"&we0&""&we&""
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select top 5 * from qingtian_yyy where pid="&strr&" order by [id] desc"
	Rs.Open Sql,conn,1,1
        	For i=1 to 5
		If Rs.Eof Then
			exit For
		End If
        body=body&"<a href='/user/liaoinfo.Asp?id="&rs("nid")&"&amp;urls="&wapturl&"&amp;sid="&sidd&"'>"&utf8(rs("name"))&"</a>:"&ubb(rs("content"))&"("&datatime(now,rs("time"))&")<br/>"
	 	Rs.MoveNext
	  	Next
	Rs.close
	set rs=nothing
        if v=0 then
        body=body&"<input emptyok='true'  type='text' name='content' value='' size='15'/><br/><anchor>聊天发言<go href='/liuyyy.Asp?pid="&strr&"&amp;urls="&wapturl&"&amp;sid="&sidd&"&amp;tsd=1' method='post'><postfield name='content' value='$(content)'/></go></anchor><a href='/liuyyy.Asp?pid="&strr&"&amp;urls="&wapturl&"&amp;sid="&sidd&"'>更多</a><br/>"
        else
        body=body&"</div><form action='/liuyyy.Asp?pid="&strr&"&amp;urls="&wapturl&"&amp;sid="&sidd&"&amp;tsd=1' method='post'><div class=""footer""><textarea name='content' rows='2'/></textarea></div><input type='submit' value='聊天发言'/><input type='submit' value='更多'/></form><br/>"
        end if
        else
        response.cookies("liao")="1"
        body=""&dao&"页面聊天[<a href='"&wapaurl&"&amp;liaoid=2'>开启</a>]"&we0&""
        end if
        liaotian=body
    End Function
    Public Function ddd
        dim rs,sql
	Set Rs = Server.CreateObject("Adodb.Recordset")
	Sql = "select top 1 shengri from qingtian_user order by [shengri] asc"
	Rs.Open Sql,conn,1,1
	if not (rs.bof and rs.eof) then
	ddd=DATEDIFF("d",rs("shengri"),now())
	else
	ddd=1
	end if
	Rs.close
	set rs=nothing
    End Function
    Public Function err(str)
        dim strr,urls
        strr=str
urls=Request.QueryString("urls")
if urls="" then
urls=backurl(WAPurl)
else
urls=backurl(urls)
end if
if v="" then v="0" 
if v="0" then
Response.Write("出错了!"&strr&"<br/>")
Response.Write("<anchor>返回来源页<prev /></anchor><br/>")
Response.Write qingtian.qingsav("700")
Response.Write("</p></card></wml>") 
else
Response.Write("<div class=""footer"">出错了!"&strr&"</div>")
Response.Write("<div class=""block4""><input type='button' name='Submit' onclick='javascript:history.back(-1);' value='返回来源页' class='submit'/></div>")
Response.Write qingtian.qingsav("700")
Response.Write("</div></body></html>") 
end if
set conn=nothing
Response.end
    End Function

    Public Function siddd(ByVal str,ByVal str1)
        dim strr,strr1
        strr=str
        strr1=str1
        strr1=Split(strr1,"-")
        siddd=strr1(strr)
    End Function
    Public Function qqbbtt()
    dim str
    str=hour(now())
    if str>3 and str<9 then
    qqbbtt="早上好"
    elseif str>8 and str<12 then
    qqbbtt="上午好"
    elseif str>11 and str<15 then
    qqbbtt="中午好"
    elseif str>14 and str<18 then
    qqbbtt="下午好"
    else 
    qqbbtt="晚上好"
    end if
    End Function
	Function WAPurl()'获取当前路径,用于返回
		dim url
		url=request.ServerVariables("SCRIPT_NAME") 
		if(len(trim(request.ServerVariables("QUERY_STRING")))>0) then 
		url=url & "?" & request.ServerVariables("QUERY_STRING")
		url=replace(url,"&","@@")
		end if 
		wapurl=url
	End Function
	Function WAPturl()'获取当前路径,用于返回
		dim url,liaod
                liaod=Request.QueryString("urls")
		url=request.ServerVariables("SCRIPT_NAME") 
		if(len(trim(request.ServerVariables("QUERY_STRING")))>0) then 
		url=url & "?" & request.ServerVariables("QUERY_STRING")
		url=replace(url,"&","@@")
		end if 
		url=replace(url,"@@urls="&liaod,"")
		wapturl=replace(url,"urls="&liaod,"")
	End Function
	Function WAPaurl()'获取当前路径,用于返回
		dim url,liaod
                liaod=Request.QueryString("liaoid")
		url=request.ServerVariables("SCRIPT_NAME") 
		if(len(trim(request.ServerVariables("QUERY_STRING")))>0) then 
		url=url & "?" & request.ServerVariables("QUERY_STRING")
                else
                url=url & "?m=1"
		end if 
		url=replace(url,"&","&amp;")
		url=replace(url,"&amp;liaoid="&liaod,"")
		wapaurl=replace(url,"liaoid="&liaod,"")
	End Function
	Function waurl()'获取当前路径,用于返回
		dim url,loasid
                loasid=Request.QueryString("sid")
		url=request.ServerVariables("SCRIPT_NAME") 
		if(len(trim(request.ServerVariables("QUERY_STRING")))>0) then 
		url=url & "?" & request.ServerVariables("QUERY_STRING")
                else
		url=url & "?m=1"
                end if
		url=replace(url,"&sid="&loasid,"")
		url=replace(url,"sid="&loasid,"m=1")
		waurl=url
	End Function
	Function waurls()'获取当前路径,用于返回
		dim url,loasid
                loasid=Request.QueryString("sid")
		url=request.ServerVariables("SCRIPT_NAME") 
		if(len(trim(request.ServerVariables("QUERY_STRING")))>0) then 
		url=url & "?" & request.ServerVariables("QUERY_STRING")
                else
		url=url & "?m=1"
                end if
		url=replace(url,"&sid="&loasid,"")
		url=replace(url,"sid="&loasid,"m=1")
		url=replace(url,"&","@@")
		waurls=url
	End Function
	Function Formatsid(ByVal xsidy)
		Formatsid=md5(xsidy) & md5(strReverse(xsidy))
	End Function

	Function FormatEdit(ByVal str)
        If Str = "" Or IsNull(Str) Then
            FormatEdit = Str
            Exit Function
        End If

        str = Replace(str, "&", "&amp;")
        str = Replace(str, "<", "&lt;")
        str = Replace(str, ">", "&gt;")
       str = Replace(str, Chr(34), "&quot;")             '双引号
        str = Replace(str, Chr(39), "&#39;")              '单引号
	str = replace(str,"","")
	str = replace(str,"^","")
	str = replace(str,"","")
	str = replace(str," ","")
	str = replace(str,"Λ","")
	str = replace(str,"Ψ","")
	str = replace(str,"","")
        str = Replace(str, "$", "$$")
        str = Replace(str, "&amp;nbsp;", "&nbsp;")
        str = Replace(str, "&amp;lt;", "&lt;")
        str = Replace(str, "&amp;gt;", "&gt;")
        str = Replace(str, "&amp;quot;", "&quot;")             '双引号
        str = Replace(str, "&amp;#39;", "&#39;")              '单引号
	FormatEdit = Str
	End Function
function CreateFolder(str)
dim UploadPath,Path,i,FSOObj
UploadPath=split(Replace(str,"\","/"),"/")
	Path = server.mappath(Request.ServerVariables("SCRIPT_NAME"))
	Path=left(Path,instrrev(Path,"\" ) - 1 )
	path=path & "/../"

	for i=0 to ubound(UploadPath)
	if UploadPath(i)<>"" then
	path=path & UploadPath(i) & "/"
    	Set FsoObj=Server.CreateObject("Scripting.FileSystemObject")
	IF FSOObj.FolderExists(path) = False then
   	FsoObj.CreateFolder(path)
	end if
	Set FsoObj=Nothing
	end if
	next

end function

Function qingsav(ByVal pid)
dim pidd,taddt
pidd=pid
Set Rs = Server.CreateObject("Adodb.Recordset")
Sql = "select [content] from qingtian_showclass where pid="&pidd&" order by [nid] asc"
Rs.Open Sql,conn,1,1
if not (rs.bof and rs.eof)  then
For i=1 to rs.RecordCount
if rs("content")="[end]" then
taddt=1
exit For
end if
%>
<!--#include file="cssdate.inc"-->
<%
qingsav=qingsav+cp.ubbshow(qingtian.wml(content))                    
                    Rs.MoveNext
			next
			end if
			Rs.close
                        set rs=nothing
if bbs=true and fv="a" then
qingsav=qingsav+"<a href='/bannji.asp?sid="&sidd&"&amp;id="&pidd&"&amp;url="&wapurl&"'>进入编辑该页面栏目</a><br/>"
end if
if taddt=1 then 
Response.Write qingsav
qingtian.tuichu
end if
end Function 
    Public Function tj(id,s)
		dim rs_1,sql_1,add,tjid

		Set Rs_1 = Server.CreateObject("Adodb.Recordset")

		Sql_1 = "select [id],[linkid],[time] from qingtian_link_tj where linkid="&id&" and DATEDIFF('d', time, now())=0 "
		Rs_1.Open Sql_1,conn,1,3
		if not (rs_1.bof and rs_1.eof)  then
			tjid=rs_1("id")
		else
			rs_1.addnew
			rs_1("time")=now
			rs_1("linkid")=id
			rs_1.update
			tjid=rs_1("id")
		end if
		Rs_1.close


		Sql_1 = "select [ip],[linkid],[tjid],[incount],[time],[tocount] from qingtian_link_tj_list where linkid="&id&" and  DATEDIFF('d', time, now())=0 and ip='"&Request.ServerVariables("REMOTE_ADDR")&"'"
		Rs_1.Open Sql_1,conn,1,3

		if not (rs_1.bof and rs_1.eof)  then
			if s="to" then
			rs_1("tocount")=rs_1("tocount")+1
			else
			rs_1("incount")=rs_1("incount")+1
			end if
			rs_1("tjid")=tjid
			rs_1("linkid")=id
			rs_1("time")=now
			rs_1("ip")=Request.ServerVariables("REMOTE_ADDR")
			rs_1.update
			add=false
		else
			rs_1.addnew
			rs_1("tjid")=tjid
			if s="to" then
			rs_1("tocount")=rs_1("tocount")+1
			else
			rs_1("incount")=rs_1("incount")+1
			end if
			rs_1("time")=now
			rs_1("linkid")=id
			rs_1("ip")=Request.ServerVariables("REMOTE_ADDR")
			rs_1.update
			add=true
		end if
		Rs_1.close

		if add=true then
			if s="to" then
			conn.execute("update qingtian_link_tj set [toCount]=[toCount]+1,toipCount=toipCount+1 where id="&tjid&"")
			conn.execute("update qingtian_link_list set [toCount]=[toCount]+1,[totime]=now() where id="&id&"")
			else
			conn.execute("update qingtian_link_tj set [inCount]=[inCount]+1,inipCount=inipCount+1 where id="&tjid&"")
			conn.execute("update qingtian_link_list set [inCount]=[inCount]+1,[intime]=now() where id="&id&"")
			end if

		end if

		set rs_1=nothing

    End Function
function CreateFile(str,Filepath)
dim txt,Path,FSO,fout
	txt=Replace(trim(str),chr(13)&chr(10),vbNewLine)

	Path = server.mappath(Request.ServerVariables("SCRIPT_NAME"))
	Path=left(Path,instrrev(Path,"\" ) - 1 )
	path=path & "/../" & Filepath

	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	IF FSO.FileExists(path) = False then
	Set fout = fso.Createtextfile(path,1,true)
	fout.write txt	'不换行
	'fout.writeline txt	'换行
	fout.close
	set fout=nothing
	end if
	set fso=nothing

end function
function CreateFilett(str,Filepath)
dim txt,Path,FSO,fout
	txt=Replace(trim(str),chr(13)&chr(10),vbNewLine)

	Path = server.mappath(Request.ServerVariables("SCRIPT_NAME"))
	Path=left(Path,instrrev(Path,"\" ) - 1 )
	path=path & "/../" & Filepath

	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	IF FSO.FileExists(path) = False then
	Set fout = fso.Createtextfile(path,true)
	fout.write txt	'不换行
	'fout.writeline txt	'换行
	fout.close
	set fout=nothing
	end if
	set fso=nothing

end function
    Public function getHTTPPageee(url) 
On Error Resume Next
Server.ScriptTimeOut=9999999
dim Http 
set Http=server.createobject("Microsoft.XMLHTTP") 
Http.open "GET",url,false 
Http.send() 
if Http.readystate<>4 then 
exit function 
end if 
getHTTPPageee=bytesToBSTR(Http.responseBody,"gb2312")  '注意WAP网页用utf-8,WEB用gb2312
set http=nothing 
if err.number<>0 then err.Clear 
end function 
    Public function getHTTPPage(url) 
On Error Resume Next
Server.ScriptTimeOut=9999999
dim Http 
set Http=server.createobject("Microsoft.XMLHTTP") 
Http.open "GET",url,false 
Http.send() 
if Http.readystate<>4 then 
exit function 
end if 
getHTTPPage=bytesToBSTR(Http.responseBody,"utf-8") '注意WAP网页用utf-8,WEB用gb2312
set http=nothing 
if err.number<>0 then err.Clear 
end function 

    Public function getHTTPPage2(url,Data) 
On Error Resume Next
Server.ScriptTimeOut=9999999
dim Http 
set Http=server.createobject("Microsoft.XMLHTTP") 
Http.open "post",url,false
Http.SetRequestHeader "User-Agent", "NokiaN95/1.0 (3.38.0)SymbianOS/9.0s Series60/3.0 Profile/MIDP-2.0 Configuration/CLDC-1.02006-7-20 16:17:07wap 2.0 GSM"
Http.SetRequestHeader "X-FORWARDED-FOR", "218.204.126.130:80"
Http.SetRequestHeader "Content-Type","application/x-www-form-urlencoded"
Http.send(Data) 
	If Http.readystate<>4 Then 
	exit function 
	End If 
getHTTPPage2=bytesToBSTR(Http.responseBody,"utf-8")
set http=nothing 
If err.number<>0 Then err.Clear 
end function

    Public function getHTTPPage1(url) 
On Error Resume Next
Server.ScriptTimeOut=9999999
dim Http 
set Http=server.createobject("Microsoft.XMLHTTP") 
Http.open "post",url,false 
Http.send() 
if Http.readystate<>4 then 
exit function 
end if 
getHTTPPage1=bytesToBSTR(Http.responseBody,"utf-8") '注意WAP网页用utf-8,WEB用gb2312
set http=nothing 
if err.number<>0 then err.Clear 
end function 
    Public Function BytesToBstr(body,Cset) 
dim objstream 
set objstream = Server.CreateObject("adodb.stream") 
objstream.Type = 1 
objstream.Mode =3 
objstream.Open 
objstream.Write body 
objstream.Position = 0 
objstream.Type = 2 
objstream.Charset = Cset 
BytesToBstr = objstream.ReadText 
objstream.Close 
set objstream = nothing 
End Function 

    Public Function weather() 
dim urll,city,a,b,c
weather=request.Cookies("weather")
if weather="" then
urll=request.Cookies("3gqingtiansf")
city=request.Cookies("3gqingtianct")
if city="" or urll="" then 
city="FoShan"
urll="guangdong"
end if
Dim Url,Html,start,over,body,wap,wstr,str
Url="http://qq.ip138.com/weather/"&urll&"/"&city&".wml"
wstr=getHTTPPage(url)            
start=Instr(wstr,"<p>")
over=Instr(wstr,"<br/><a href=""/weather/weather_prov.wml"">&gt;按省份查询天气</a><br/>")
body=mid(wstr,start,over-start)
body = replace(body,"</td>","")
body = replace(body,"<td>","")
body = replace(body,"</tr>","<br/>")
body = replace(body,"<tr>","")
body = replace(body,"<br/><br/><br/><b>","<br/><br/><b>")
body = replace(body,"</p>","")
body = replace(body,"<p>","")
if body="" then
weather="天气情况无法获取<a href='/weather/index.asp?sid="&sidd&"'>查询</a>"
else
bodyy=replace(body,"<br/><br/>","<br/>")
bodyy=trim(bodyy)
bodyy=Split(bodyy,"<br/>")
if Instr(bodyy(0),"内蒙古")>0 or Instr(bodyy(0),"黑龙江")>0 then
a = replace(bodyy(0),left(bodyy(0),5),"") 
else
a = replace(bodyy(0),left(bodyy(0),4),"") 
end if
a = replace(a,"天气预报","")
b = bodyy(2)
c = bodyy(3)
weather="天气<img src=""/b1.gif"" alt='' noselect = ""true"" /><a href='/weather/index.asp?sid=[sid]'>"&a&"</a>"&b&c
	Response.Cookies("weather")=weather
	Response.Cookies("weather").Expires = Date + 1 '一月内有效
weather=wml(weather)
end if
end if
End Function 
    Public Function touxian(str)
dim fs,SourceFile,TargetFile,j
randomize
str1="/photo/photo/"&qingtian.nid&int(3*rnd+1)&".gif"
on error resume next
Set fs = Server.CreateObject("Scripting.FileSystemObject")
SourceFile = server.MapPath(str)
TargetFile = server.MapPath(str1)
fs.deletefile(TargetFile)
fs.CopyFile SourceFile, TargetFile
set fs = Nothing
conn.Execute("update qingtian_user set touxian='"&str1&"' where id="&qingtian.nid)
set j=server.createobject("persits.jpeg")
j.open server.mappath(str1)
j.width=138
j.height=140
j.save server.mappath(str1)
j.close
set j=nothing
touxian="设置头像成功"
    End Function
    Public Function rndd(str)
    dim str1
If InStr(str,"|") <= 0 Then
rndd=str
else
str=Split(str, "|")
randomize
str1=int((UBound(str)+1)*rnd+1)
str1=str1-1
if str1>ubound(str) then str1=ubound(str)
rndd=str(str1)
end if
    End Function
    Public Function phonename(str,str1)
    str=clng(str)
Set Rs = Server.CreateObject("Adodb.Recordset")
Sql = "select bid,name,name1 from qingtian_phonemob where id="&str&" order by id desc"
Rs.Open Sql,conn,1,1
if not (rs.bof and rs.eof)  then
if str1="1" then
phonename=rs("bid")
elseif str1="2" then
phonename=rs("name")
else
phonename=rs("name1")
end if
end if
Rs.close
set rs=nothing
    End Function
    Public Function phonetol(str)
dim strr
strr=str
phonetol=qingtian.phonename(midqd,3)&"[<a href='phone.asp?urls="&strr&"&amp;sid="&sidd&"'>更改</a>]"
    End Function
Public Function shuru()
	Response.Buffer = True 
select case v
case "0"
	Response.ExpiresAbsolute = Now() - 1 
	Response.Expires = 0 
	Response.CacheControl = "no-cache" 
	Response.AddHeader "Pragma", "no-cache"
	Response.AddHeader "Cache-Control", "no-cache, must-revalidate"
Response.ContentType = "text/vnd.wap.wml; charset=utf-8"
Response.Write "<?xml version=""1.0"" encoding=""utf-8""?>" & chr(13) & chr(10)
        Response.Write "<!DOCTYPE wml PUBLIC ""-//WAPFORUM//DTD WML 1.2//EN"" ""http://www.wapforum.org/DTD/wml12.dtd"">" & chr(13) & chr(10)
        Response.Write "<wml>" & chr(13) & chr(10)
        Response.Write "<head>" & chr(13) & chr(10)
        Response.Write "<meta http-equiv=""Cache-Control"" content=""ust-revalidate"" forua=""true""/>" & chr(13) & chr(10)
        Response.Write "<meta http-equiv=""Cache-Control"" content=""no-cache"" forua=""true""/>" & chr(13) & chr(10)
        Response.Write "<meta http-equiv=""Cache-Control"" content=""max-age=0"" forua=""true""/>" & chr(13) & chr(10)
        Response.Write "<meta http-equiv=""Expires"" content=""0"" forua=""true""/>" & chr(13) & chr(10)
        Response.Write "<meta http-equiv=""Pragma"" content=""no-cache"" forua=""true""/>" & chr(13) & chr(10)
        Response.Write "</head>"

case "1"
   Response.Write "<?xml version=""1.0"" encoding=""utf-8""?>" & chr(13) & chr(10)
   Response.Write "<!DOCTYPE html PUBLIC ""-//WAPFORUM//DTD XHTML Mobile 1.0//EN"" ""http://www.wapforum.org/DTD/xhtml-mobile10.dtd"">" & chr(13) & chr(10)
        Response.Write "<html xmlns=""http://www.w3.org/1999/xhtml"">" & chr(13) & chr(10)
        Response.Write "<head>" & chr(13) & chr(10) & "<meta http-equiv=""content-type"" content=""application/xhtml+xml; charset=UTF-8""/>" & chr(13) & chr(10) 
 Response.Write "<meta name=""keywords"" content=""把妹泡|泡妞|恋爱|搭讪|约会|把妹|惯例|技巧|一把妹泡网"" />" & chr(13) & chr(10)
 Response.Write "<link rel=""stylesheet"" href=""/css/"&fv&".css"" type=""text/css"" />" & chr(13) & chr(10)
End Select
     End Function
    Public Function shuchu()
if v="" then v="0" 
if v="0" then
%>
<%=qingtian.qingsav("700")%>
</p>
</card>
</wml> 
<%else%>
<%=qingtian.qingsav("700")%>
</body>
</html>
<%
end if
response.write("<!--晴天3G建站系统-wap.qt3g.com-->")
conn.close
set conn=nothing
Response.end
    End Function
 Public Function tuichu()
dim tuichuu
if v="" then v="0" 
if v="0" then
tuichuu="</p>" & chr(13) & chr(10) & "</card>" & chr(13) & chr(10) & "</wml>" & chr(13) & chr(10) & "<!--晴天3G建站系统-wap.qt3g.com-->"
else
tuichuu="</body>" & chr(13) & chr(10) & "</html>" & chr(13) & chr(10) & "<!--晴天3G建站系统-wap.qt3g.com-->"
end if
Response.Write tuichuu
conn.close
set conn=nothing
Response.end
    End Function
public function getNongli()
dim WeekName(7), MonthAdd(11), NongliData(99), TianGan(9), DiZhi(11), ShuXiang(11), DayName(30), MonName(12)
dim curTime, curYear, curMonth, curDay, curWeekday
dim GongliStr, WeekdayStr, NongliStr, NongliDayStr
dim i, m, n, k, isEnd, bit, TheDate

'星期名
WeekName(0) = "*"
WeekName(1) = "星期日"
WeekName(2) = "星期一"
WeekName(3) = "星期二"
WeekName(4) = "星期三"
WeekName(5) = "星期四"
WeekName(6) = "星期五"
WeekName(7) = "星期六"

'天干名称
TianGan(0) = "甲"
TianGan(1) = "乙"
TianGan(2) = "丙"
TianGan(3) = "丁"
TianGan(4) = "戊"
TianGan(5) = "己"
TianGan(6) = "庚"
TianGan(7) = "辛"
TianGan(8) = "壬"
TianGan(9) = "癸"

'地支名称
DiZhi(0) = "子"
DiZhi(1) = "丑"
DiZhi(2) = "寅"
DiZhi(3) = "卯"
DiZhi(4) = "辰"
DiZhi(5) = "巳"
DiZhi(6) = "午"
DiZhi(7) = "未"
DiZhi(8) = "申"
DiZhi(9) = "酉"
DiZhi(10) = "戌"
DiZhi(11) = "亥"

'属相名称
ShuXiang(0) = "鼠"
ShuXiang(1) = "牛"
ShuXiang(2) = "虎"
ShuXiang(3) = "兔"
ShuXiang(4) = "龙"
ShuXiang(5) = "蛇"
ShuXiang(6) = "马"
ShuXiang(7) = "羊"
ShuXiang(8) = "猴"
ShuXiang(9) = "鸡"
ShuXiang(10) = "狗"
ShuXiang(11) = "猪"

'农历日期名
DayName(0) = "*"
DayName(1) = "初一"
DayName(2) = "初二"
DayName(3) = "初三"
DayName(4) = "初四"
DayName(5) = "初五"
DayName(6) = "初六"
DayName(7) = "初七"
DayName(8) = "初八"
DayName(9) = "初九"
DayName(10) = "初十"
DayName(11) = "十一"
DayName(12) = "十二"
DayName(13) = "十三"
DayName(14) = "十四"
DayName(15) = "十五"
DayName(16) = "十六"
DayName(17) = "十七"
DayName(18) = "十八"
DayName(19) = "十九"
DayName(20) = "二十"
DayName(21) = "廿一"
DayName(22) = "廿二"
DayName(23) = "廿三"
DayName(24) = "廿四"
DayName(25) = "廿五"
DayName(26) = "廿六"
DayName(27) = "廿七"
DayName(28) = "廿八"
DayName(29) = "廿九"
DayName(30) = "三十"

'农历月份名
MonName(0) = "*"
MonName(1) = "正"
MonName(2) = "二"
MonName(3) = "三"
MonName(4) = "四"
MonName(5) = "五"
MonName(6) = "六"
MonName(7) = "七"
MonName(8) = "八"
MonName(9) = "九"
MonName(10) = "十"
MonName(11) = "十一"
MonName(12) = "腊"

'公历每月前面的天数
MonthAdd(0) = 0
MonthAdd(1) = 31
MonthAdd(2) = 59
MonthAdd(3) = 90
MonthAdd(4) = 120
MonthAdd(5) = 151
MonthAdd(6) = 181
MonthAdd(7) = 212
MonthAdd(8) = 243
MonthAdd(9) = 273
MonthAdd(10) = 304
MonthAdd(11) = 334

'农历数据
NongliData(0) = 2635
NongliData(1) = 333387
NongliData(2) = 1701
NongliData(3) = 1748
NongliData(4) = 267701
NongliData(5) = 694
NongliData(6) = 2391
NongliData(7) = 133423
NongliData(8) = 1175
NongliData(9) = 396438
NongliData(10) = 3402
NongliData(11) = 3749
NongliData(12) = 331177
NongliData(13) = 1453
NongliData(14) = 694
NongliData(15) = 201326
NongliData(16) = 2350
NongliData(17) = 465197
NongliData(18) = 3221
NongliData(19) = 3402
NongliData(20) = 400202
NongliData(21) = 2901
NongliData(22) = 1386
NongliData(23) = 267611
NongliData(24) = 605
NongliData(25) = 2349
NongliData(26) = 137515
NongliData(27) = 2709
NongliData(28) = 464533
NongliData(29) = 1738
NongliData(30) = 2901
NongliData(31) = 330421
NongliData(32) = 1242
NongliData(33) = 2651
NongliData(34) = 199255
NongliData(35) = 1323
NongliData(36) = 529706
NongliData(37) = 3733
NongliData(38) = 1706
NongliData(39) = 398762
NongliData(40) = 2741
NongliData(41) = 1206
NongliData(42) = 267438
NongliData(43) = 2647
NongliData(44) = 1318
NongliData(45) = 204070
NongliData(46) = 3477
NongliData(47) = 461653
NongliData(48) = 1386
NongliData(49) = 2413
NongliData(50) = 330077
NongliData(51) = 1197
NongliData(52) = 2637
NongliData(53) = 268877
NongliData(54) = 3365
NongliData(55) = 531109
NongliData(56) = 2900
NongliData(57) = 2922
NongliData(58) = 398042
NongliData(59) = 2395
NongliData(60) = 1179
NongliData(61) = 267415
NongliData(62) = 2635
NongliData(63) = 661067
NongliData(64) = 1701
NongliData(65) = 1748
NongliData(66) = 398772
NongliData(67) = 2742
NongliData(68) = 2391
NongliData(69) = 330031
NongliData(70) = 1175
NongliData(71) = 1611
NongliData(72) = 200010
NongliData(73) = 3749
NongliData(74) = 527717
NongliData(75) = 1452
NongliData(76) = 2742
NongliData(77) = 332397
NongliData(78) = 2350
NongliData(79) = 3222
NongliData(80) = 268949
NongliData(81) = 3402
NongliData(82) = 3493
NongliData(83) = 133973
NongliData(84) = 1386
NongliData(85) = 464219
NongliData(86) = 605
NongliData(87) = 2349
NongliData(88) = 334123
NongliData(89) = 2709
NongliData(90) = 2890
NongliData(91) = 267946
NongliData(92) = 2773
NongliData(93) = 592565
NongliData(94) = 1210
NongliData(95) = 2651
NongliData(96) = 395863
NongliData(97) = 1323
NongliData(98) = 2707
NongliData(99) = 265877

'获取当前系统时间
curTime = Now()

'生成当前公历年、月、日 ==> GongliStr
curYear = Year(curTime)
curMonth = Month(curTime)
curDay = Day(curTime)

GongliStr = curYear&"年"
If (curMonth < 10) Then
GongliStr = GongliStr&"0"&curMonth&"月"
Else
GongliStr = GongliStr&curMonth&"月"
End If
If (curDay < 10) Then
GongliStr = GongliStr&"0"&curDay&"日"
Else
GongliStr = GongliStr&curDay&"日"
End If 

'生成当前公历星期 ==> WeekdayStr
curWeekday = Weekday(curTime)
WeekdayStr = WeekName(curWeekday)

'计算到初始时间1921年2月8日的天数：1921-2-8(正月初一)
TheDate = (curYear - 1921) * 365 + Int((curYear - 1921) / 4) + curDay + MonthAdd(curMonth - 1) - 38
If ((curYear Mod 4) = 0 AND curMonth > 2) Then
TheDate = TheDate + 1
End If

'计算农历天干、地支、月、日
isEnd = 0
m = 0

Do
If (NongliData(m) < 4095) Then
k = 11
Else
k = 12
End if

n = k
Do
If (n < 0) Then
Exit Do
End If

'获取NongliData(m)的第n个二进制位的值
bit = NongliData(m)
For i = 1 To n Step 1
bit = Int(bit / 2)
Next
bit = bit Mod 2

If (TheDate <= 29 + bit) Then
isEnd = 1
Exit Do
End If

TheDate = TheDate - 29 - bit

n = n - 1
Loop

If (isEnd = 1) Then
Exit Do
End If

m = m + 1
Loop

curYear = 1921 + m
curMonth = k - n + 1
curDay = TheDate

If (k = 12) Then
If (curMonth = (Int(NongliData(m) / 65536) + 1)) Then
curMonth = 1 - curMonth
ElseIf (curMonth > (Int(NongliData(m) / 65536) + 1)) Then
curMonth = curMonth - 1
End if

End If

'生成农历天干、地支、属相 ==> NongliStr
NongliStr = "农历"&TianGan(((curYear - 4) Mod 60) Mod 10)&DiZhi(((curYear - 4) Mod 60) Mod 12)&"年"
NongliStr = NongliStr&"("&ShuXiang(((curYear - 4) Mod 60) Mod 12)&")"

'生成农历月、日 ==> NongliDayStr
If (curMonth < 1) Then
NongliDayStr = "闰"&MonName(-1 * curMonth)
Else
NongliDayStr = MonName(curMonth)
End If
NongliDayStr = NongliDayStr&"月"

NongliDayStr = NongliDayStr&DayName(curDay)
getNongli=NongliStr&NongliDayStr
end function
end class
%>